home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / zread.t < prev    next >
Text File  |  1988-05-02  |  8KB  |  220 lines
  1. (herald zread
  2.   (env tsys
  3.        (osys vm_port)))
  4.  
  5. ;;; Copyright (c) 1985 Yale University
  6. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  7. ;;; This material was developed by the T Project at the Yale University Computer 
  8. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  9. ;;; and to use it for any purpose is granted, subject to the following restric-
  10. ;;; tions and understandings.
  11. ;;; 1. Any copy made of this software must include this copyright notice in full.
  12. ;;; 2. Users of this software agree to make their best efforts (a) to return
  13. ;;;    to the T Project at Yale any improvements or extensions that they make,
  14. ;;;    so that these may be included in future releases; and (b) to inform
  15. ;;;    the T Project of noteworthy uses of this software.
  16. ;;; 3. All materials developed as a consequence of the use of this software
  17. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  18. ;;;    of acknowledging credit in academic research.
  19. ;;; 4. Yale has made no warrantee or representation that the operation of
  20. ;;;    this software will be error-free, and Yale is under no obligation to
  21. ;;;    provide any services, by way of maintenance, update, or otherwise.
  22. ;;; 5. In conjunction with products arising from the use of this material,
  23. ;;;    there shall be no use of the name of the Yale University nor of any
  24. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  25. ;;;    without prior written consent from Yale in each case.
  26. ;;;
  27.  
  28. ;;; Z system reader
  29.  
  30. (define-constant %%close-paren (cons '**close-paren** '()))
  31. (define-constant %%dot         (cons '**dot** '()))
  32. (define-constant %%escape-character  #\\)
  33.  
  34. (lset *z-input-radix* 10)
  35.  
  36. (define (z-read iob)
  37.   (let ((form (z-sub-read iob)))
  38.     (cond ((eq? form %%dot)
  39.            (error "\" . \" in illegal context."))
  40.           ((eq? form %%close-paren)
  41.            (z-read iob))
  42.           (else form))))
  43.  
  44. (define (z-sub-read iob)
  45.   (let ((c (vm-read-char iob)))
  46.     (cond ((eof? c)   c)
  47.           ((whitespace? c) (z-sub-read iob))
  48.           ((char= c #\()    (z-read-list iob))
  49.           ((char= c #\))    %%close-paren)
  50.           ((char= c #\.)    %%dot)
  51.           ((char= c #\')    (list 'quote (z-sub-read iob)))
  52.           ((char= c #\`)    (list 'quasiquote (z-sub-read iob)))
  53.           ((char= c #\,)    (list (cond ((char= (vm-peek-char iob) #\@)
  54.                                          (vm-read-char iob)
  55.                                          'unquote-splicing)
  56.                                         (else 'unquote))
  57.                                   (z-sub-read iob)))
  58.           ((char= c #\#)    (z-sharpsign-read-macro iob))
  59.           ((char= c #\")    (z-read-string iob))
  60.           ((char= c #\;)    (z-read-comment iob))
  61.           ((char= c #\-)
  62.            (if (digit (vm-peek-char iob) *z-input-radix*)
  63.                (z-read-signed-number iob -1 *z-input-radix*)
  64.                (z-read-symbol iob c)))
  65.           ((char= c #\+)
  66.            (if (digit (vm-peek-char iob) *z-input-radix*)
  67.                (z-read-signed-number iob 1 *z-input-radix*)
  68.                (z-read-symbol iob c)))
  69.           ((digit c *z-input-radix*)
  70.            => (lambda (c)
  71.                 (z-read-number iob c *z-input-radix*)))
  72.           (else
  73.            (z-read-symbol iob c)))))
  74.  
  75.  
  76. (define (z-sharpsign-read-macro iob)
  77.   (let ((c (vm-read-char iob)))
  78.     (cond ((or (char= c #\o) (char= c #\O))
  79.            (z-read-number iob (vm-read-char iob) 8))
  80.           ((or (char= c #\x) (char= c #\X))
  81.            (z-read-number iob (vm-read-char iob) 16))
  82.           ((or (char= c #\b) (char= c #\B))
  83.            (z-read-number iob (vm-read-char iob) 2))
  84.           ((char= c #\\)
  85.            (vm-read-char iob))
  86.           ((char= c #\.)
  87.            (z-eval (z-sub-read iob) *z-repl-env*))
  88.           ((char= c #\[)
  89.            (let ((key (z-read-symbol iob (vm-read-char iob))))
  90.              (case key
  91.               ((comex)
  92.                (read-comex iob)
  93.                (vm-read-char iob)) ; #\]  ;++ check for errors?
  94.               (else
  95.                (error "unknown syntax #[~a ...]." key)))))
  96.           (else
  97.            (error "unknown sharpsign read macro - ~a~&" c)))))
  98.  
  99.  
  100. (define (z-read-list iob)
  101.   (let ((form (z-sub-read iob)))
  102.     (cond ((eof? form) form)
  103.           ((eq? form %%close-paren) '())
  104.           ((eq? form %%dot) (z-read-tail iob))
  105.           (else (cons form (z-read-list iob))))))
  106.  
  107. (define (z-read-tail iob)
  108.   (let ((last-form (z-sub-read iob)))
  109.     (cond ((eof? last-form)              last-form)
  110.           ((eq? last-form %%close-paren) '())
  111.           ((eq? last-form %%dot)         (z-read-tail iob))
  112.           (else
  113.            (let ((another-form (z-sub-read iob)))
  114.              (cond ((eq? another-form %%close-paren) last-form)
  115.                    ((eq? another-form %%dot) (cons last-form
  116.                                                    (z-read-tail iob)))
  117.                    (else (cons last-form (z-read-list iob)))))))))
  118.  
  119. (define (z-read-signed-number iob sign radix)
  120.   ;++ loses on %%minimum-fixnum.
  121.   (fx* sign (z-read-number iob (digit (vm-read-char iob) radix) radix)))
  122.  
  123. (define-recursive (z-read-number iob n radix)
  124.   (let* ((c (vm-peek-char iob))
  125.          (v (digit c radix)))
  126.     (cond (v
  127.            ;; accept the character
  128.            (vm-read-char iob)
  129.            (z-read-number iob (fx+ v (fx* n radix)) radix))
  130.           ;; eat trailing dots on numbers
  131.           ((and (char= c #\.)
  132.                 (vm-read-char iob)
  133.                 (not (whitespace? (vm-peek-char iob))))
  134.            (error "floating point numbers are not implemented in the Z system."))
  135.           (else n))))
  136.  
  137. (define (z-read-string iob)
  138.   (iterate loop ((l '()))
  139.     (let ((c (vm-read-char iob)))
  140.       (cond ((eof? c)
  141.              (error "end of file within a string."))
  142.             ((char= c %%escape-character)
  143.              (loop (cons (z-read-escaped-char iob) l)))
  144.             ((char= c #\") (backwards-list->string l))
  145.             (else (loop (cons c l)))))))
  146.  
  147. (define (z-read-escaped-char iob)
  148.   (let ((c (vm-read-char iob)))
  149.     (cond ((or (char= c #\\) (char= c #\")) c)
  150.           (else
  151.            (error "invalid escaped character - ~a~&" c)))))
  152.  
  153. (define (z-read-symbol iob c)
  154.   (iterate loop ((l (cons (char-upcase c) '())))
  155.     (cond ((z-break-char? (vm-peek-char iob))
  156.            (string->symbol (backwards-list->string l)))
  157.           (else
  158.            (loop (cons (char-upcase (vm-read-char iob)) l))))))
  159.  
  160. (define (backwards-list->string l)
  161.     (let* ((len (length l))
  162.            (str (make-string len))
  163.            (text (string-text str)))
  164.         (do ((i (fx- len 1) (fx- i 1))
  165.              (l l (cdr l)))
  166.             ((fx< i 0) str)
  167.           (set (text-elt text i) (car l)))))
  168.  
  169.  
  170. (define (z-read-comment iob)
  171.   (let ((c (vm-read-char iob)))
  172.     (cond ((eof? c) c)                     ; no test with conditions
  173.           ((char= c #\newline) (z-sub-read iob))
  174.           (else (z-read-comment iob)))))
  175.  
  176. (define (z-break-char? c)
  177.   (or (char= c #\()
  178.       (char= c #\))
  179.     ;  (char= c #\.)  ;++ symbols can have dots
  180.       (char= c #\;)
  181.       (whitespace? c)))
  182.  
  183. (comment
  184.     ;++ flush this stuff
  185.     ;;; random auxiliaries (actually duplicates of character and string
  186.     ;;; code!)
  187.  
  188.     (define-constant %%alpha     (char->ascii #\a))
  189.     (define-constant %%cap-alpha (char->ascii #\A))
  190.     (define-constant %%zed       (char->ascii #\z))
  191.     (define-constant %%zero      (char->ascii #\0))
  192.     (define-constant %%nine      (char->ascii #\9))
  193.  
  194.     (define (z-whitespace? c)
  195.       (cond ((or (char= c #\space)
  196.                  (char= c #\tab)
  197.                  (char= c #\newline))
  198.              t)
  199.              (else nil)))
  200.  
  201.     (define (z-char-upcase c)
  202.       (let ((c (char->ascii c)))
  203.         (ascii->char (cond ((and (fx>= c %%alpha)
  204.                                  (fx<= c %%zed))
  205.                             (fx- c (fx- %%alpha %%cap-alpha)))
  206.                            (else c)))))
  207.  
  208.     (define (z-digit c radix)
  209.       (let ((c (char->ascii (z-char-upcase c))))
  210.         (cond ((and (fx>= c %%zero)
  211.                     (fx<= c (fixnum-min (fx+ radix %%zero) (fx+ %%nine 1))))
  212.                (fx- c %%zero))
  213.               ((and (fx> radix 10)
  214.                     (fx>= c %%cap-alpha)
  215.                     (fx< c (fx+ %%cap-alpha (fx- radix 10))))
  216.                (fx+ (fx- c %%cap-alpha) 10))
  217.               (else nil))))
  218.  
  219.  )
  220.